home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / tptc17sc.zip / TPCDECL.INC < prev    next >
Text File  |  1988-03-26  |  17KB  |  728 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9. (********************************************************************)
  10. (*
  11.  * process pascal data type specifications
  12.  *
  13.  *)
  14.  
  15. function psimpletype: string80;
  16.    {parse a simple (single keyword and predefined) type; returns the
  17.     translated type specification; sets the current data type}
  18. var
  19.    sym: symptr;
  20.  
  21. begin
  22.    if debug_parse then write(' <simpletype>');
  23.  
  24.    sym := locatesym(ltok);
  25.    if sym <> nil then
  26.    begin
  27.       curtype := sym^.symtype;
  28.       if cursuptype = ss_none then
  29.          cursuptype := sym^.suptype;
  30.       curlimit := sym^.limit;
  31.       curbase := sym^.base;
  32.       curpars := sym^.parcount;
  33.    end;
  34.  
  35.    psimpletype := usetok;
  36. end;
  37.  
  38.  
  39. (********************************************************************)
  40. procedure pdatatype(stoclass: anystring;
  41.                     var vars: paramlist;
  42.                     prefix:   anystring;
  43.                     suffix:   anystring;
  44.                     addsemi:  boolean);
  45.    {parse any full data type specification;  input is a list of variables
  46.     to be declared with this data type; stoclass is a storage class prefix
  47.     (usually 'static ', '', 'typedef ', or 'extern '.  prefix and suffix
  48.     are variable name modifiers used in pointer and subscript translations;
  49.     recursive for complex data types}
  50.  
  51. const
  52.    forward_typedef: anystring = '';
  53.    forward_undef:   anystring = '';
  54.  
  55. var
  56.    i:      integer;
  57.    ts:     anystring;
  58.    ex:     anystring;
  59.    sym:    symptr;
  60.    nbase:  integer;
  61.    bbase:  integer;
  62.    nsuper: supertypes;
  63.    
  64.    procedure pvarlist;
  65.    var
  66.       i:    integer;
  67.       pcnt: integer;
  68.  
  69.    begin
  70.       ts := '';
  71.       pcnt := -1;
  72.             
  73.       if tok = 'ABSOLUTE' then
  74.       begin
  75.          if debug_parse then write(' <abs>');
  76.          gettok;        {consume the ABSOLUTE}
  77.          ts := pexpr;   {get the absolute lvalue}
  78.  
  79.          if tok[1] = ':' then    {absolute addressing}
  80.          begin
  81.             gettok;
  82.             ts := ' = MK_FP('+ts+','+pexpr+')';
  83.          end
  84.          
  85.          else                 {variable aliasing}
  86.          begin
  87.             if ts[1] = '*' then
  88.                ts := ' = ' + copy(ts,2,255)
  89.             else
  90.                ts := ' = &(' + ts + ')';
  91.          end;
  92.          
  93.          {convert new variable into a pointer if needed}
  94.          if length(prefix) = 0 then
  95.             prefix := '*';
  96.             
  97.          {force automatic pointer dereference in expressions}
  98.          pcnt := -2;
  99.       end;
  100.  
  101.       if cursuptype = ss_none then
  102.          cursuptype := ss_scalar;
  103.                           
  104.       for i := 1 to vars.n do
  105.       begin
  106.          newsym(vars.id[i],curtype,cursuptype,pcnt,withlevel,curlimit,nbase);
  107.          puts(prefix+vars.id[i]+suffix+ts);
  108.          if i < vars.n then
  109.             puts(', ');
  110.       end;
  111.    end;
  112.  
  113.  
  114.    procedure parray;
  115.    begin
  116.       if debug_parse then write(' <array>');
  117.       gettok;     {consume the ARRAY}
  118.  
  119.       repeat
  120.          gettok;        {consume the [ or ,}
  121.  
  122.          ts := pexpr;   {consume the lower subscript expression}
  123.          if isnumber(ts) then
  124.             nbase := atoi(ts)
  125.          else
  126.             nbase := curbase;
  127.  
  128.          if tok = '..' then
  129.          begin
  130.             gettok;   {consume the ..}
  131.             ts := pexpr;
  132.  
  133.             subtract_base(ts,nbase-1);
  134.          end
  135.          else
  136.  
  137.          begin    {subscript by typename - look up type range}
  138.             sym := locatesym(ts);
  139.             if sym <> nil then
  140.             begin
  141.                nbase := sym^.base;
  142.                if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
  143.                   ts := ' /* ' + ts + ' */ ' + itoa(sym^.limit-nbase+1);
  144.             end;
  145.          end;
  146.    
  147.          suffix := suffix + '[' + ts + ']'; 
  148.  
  149.       until tok[1] <> ',';
  150.       
  151.       gettok;     {consume the ]}
  152.       gettok;     {consume the OF}
  153.  
  154.       cursuptype := ss_array;
  155.    end;
  156.  
  157.  
  158.    procedure pstring;
  159.    begin
  160.       if debug_parse then write(' <string>');
  161.       gettok;     {consume the STRING}
  162.  
  163.       if tok[1] = '[' then
  164.       begin
  165.          gettok;     {consume the [}
  166.  
  167.          nsuper := cursuptype;
  168.          ts := pexpr;
  169.          cursuptype := nsuper;
  170.          subtract_base(ts,-1);            {increment string size by one}
  171.          suffix := suffix + '[' + ts + ']'; 
  172.          
  173.          gettok;     {consume the ]}
  174.       end
  175.       else
  176.          suffix := suffix + '[STRSIZ]';
  177.  
  178.       puts(ljust(stoclass+'char',identlen));
  179.       curtype := s_string;
  180.       nbase := 1;
  181.       pvarlist;
  182.    end;
  183.  
  184.  
  185.    procedure ptext;
  186.    begin
  187.       if debug_parse then write(' <text>');
  188.       gettok;     {consume the TEXT}
  189.  
  190.       if tok[1] = '[' then
  191.       begin
  192.          gettok;     {consume the [}
  193.          nsuper := cursuptype;
  194.          ts := pexpr;
  195.          cursuptype := nsuper;
  196.          gettok;     {consume the ]}
  197.       end;
  198.  
  199.       puts(ljust(stoclass+'text',identlen));
  200.       curtype := s_file;
  201.       pvarlist;
  202.    end;
  203.  
  204.  
  205.    procedure pfile;
  206.    begin
  207.       if debug_parse then write(' <file>');
  208.       gettok;     {consume the FILE}
  209.  
  210.       if tok = 'OF' then
  211.       begin
  212.          gettok;     {consume the OF}
  213.          ts := tok;
  214.          gettok;     {consume the recordtype}
  215.          ts := '/* file of '+ts+' */ ';
  216.       end
  217.       else
  218.          ts := '/* untyped file */ ';
  219.  
  220.       puts(ljust(stoclass+'int',identlen)+ts);
  221.       curtype := s_file;
  222.       pvarlist;
  223.    end;
  224.  
  225.  
  226.    procedure pset;
  227.    begin
  228.       if debug_parse then write(' <set>');
  229.       gettok;     {consume the SET}
  230.       gettok;     {consume the OF}
  231.  
  232.       ts := '/* ';
  233.       if toktype = identifier then
  234.          ts := ts + usetok
  235.       else
  236.  
  237.       if tok = '(' then
  238.       begin
  239.          repeat
  240.             ts := ts + usetok
  241.          until (tok[1] = ')') or recovery;
  242.          ts := ts + usetok;
  243.       end
  244.  
  245.       else
  246.          ts := ts + psetof;
  247.  
  248.       puts(ljust(stoclass+'setrec',identlen)+ts+' */ ');
  249.       curtype := s_struct;
  250.       pvarlist;
  251.    end;
  252.  
  253.  
  254.    procedure pvariant;
  255.    begin
  256.       if debug_parse then write(' <variant>');
  257.       gettok;     {consume the CASE}
  258.  
  259.       ts := ltok;
  260.       gettok;     {consume the selector identifier}
  261.  
  262.       if tok[1] = ':' then
  263.       begin
  264.          gettok;     {consume the :}
  265.          puts(ltok+' '+ts+ ';  /* Selector */');
  266.          gettok;     {consume the selector type}
  267.       end
  268.       else
  269.          puts(' /* Selector is '+ts+' */');
  270.  
  271.       gettok;
  272.       puts('union { ');
  273.       newline;
  274.  
  275.       while (tok <> '}') and not recovery do
  276.       begin
  277.          ts := pexpr;      {parse the selector constant}
  278.          while tok[1] = ',' do
  279.          begin
  280.             gettok;
  281.             ts := pexpr;
  282.          end;
  283.  
  284.          gettok;    {consume the :}
  285.  
  286.          puts(' struct {  ');
  287.  
  288.          ts := 's' + ts;
  289.          decl_prefix := 'v.'+ts+'.';
  290.          pvar;
  291.          decl_prefix := '';
  292.          
  293.          gettok;    {consume the ')'}
  294.  
  295.          puts(' } '+ts+';');
  296.  
  297.          {arrange for reference translation}
  298.          newsym(ts,s_void,ss_struct,-1,0,0,0);
  299.          cursym^.repid := ts;
  300.  
  301.          if tok[1] = ';' then
  302.             gettok;
  303.       end;
  304.  
  305.       puts(' } v;');
  306.       newline;
  307.    end;
  308.  
  309.  
  310.    procedure precord;
  311.    begin
  312.       if debug_parse then write(' <record>');
  313.       puts(stoclass+'struct '+vars.id[1]+' { ');
  314.  
  315.       inc(withlevel);
  316.       pvar;     {process each record member}
  317.  
  318.       if tok = 'CASE' then    {process the variant part, if any}
  319.          pvariant;
  320.       dec(withlevel);
  321.  
  322.       puttok;   {output the closing brace}
  323.       gettok;   {and consume it}
  324.  
  325.       curtype := s_struct;
  326.       cursuptype := ss_struct;
  327.       pvarlist; {output any variables of this record type}
  328.  
  329.       {convert a #define into a typedef in case of a forward pointer decl}
  330.       if length(forward_typedef) > 0 then
  331.       begin
  332.          puts(';'); 
  333.          newline;
  334.          puts(forward_undef); 
  335.          n